home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr53
/
122_01.zip
/
PISTOL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-06-02
|
42KB
|
1,749 lines
(*
*********************************************************
* *
* PISTOL-Portably Implemented Stack Oriented Language *
* Version 1.3 *
* (C) 1982 by Ernest E. Bergmann *
* Physics, Building #16 *
* Lehigh Univerisity *
* Bethlehem, Pa. 18015 *
* *
* Permission is hereby granted for all reproduction and *
* distribution of this material provided this notice is *
* is included. *
* *
*********************************************************
*)
PROGRAM PISTOL(INPUT:/);
(*DECEMBER 22, 1981 --FOR BEST PERFORMANCE IN PASCAL,
THIS PROGRAM SHOULD BE EDITED TO MAKE FULL USE
OF THE OPTIONS, USER=0,W=1,S=1,CSTEP=1,L=1,R=1
AND STRINGSMIN=-1 *)
LABEL 99;
CONST
VERSION=13;(*10* THE VERSION NUMBER,READABLE BY USER*)
USER=0;(*DISPLACEMENT FOR USER'S RAM AREA; IT SHOULD
BE CHANGED TO SIMPLIFY ADDRESS CALCULATION IN
ASSEMBLY CODE IMPLEMENTATIONS*)
W=1;(*RAM ADDRESS INCREMENT SIZE; TYPICALLY WOULD BE
2 OR 4 FOR 8-BIT MICROS AND OTHER BYTE ADDRESSABLE
MACHINES*)
R=1;(*INCREMENT SIZE FOR RSTACK,HIDDEN FROM USER*)
S=1;(*INCREMENT SIZE FOR (PARAMETER) STACK,HIDDEN*)
STACKMIN=0;(*WHATEVER IS CONVENIENT,HIDDEN FROM USER*)
MSTACKMIN=-3;(*STACKMIN-S*3*)
PSTACKMAX=203;(*STACKMAX+S*3*)
STACKMAX=200;(*STACKMIN+SSIZE*S*)
LSTACKMIN=0;(*WHATEVER IS CONVENIENT,HIDDEN FROM USER*)
L=1;(*LSTACK INCREMENT,HIDDEN FROM USER*)
LSTACKMAX=30;(*LSTACKMIN+LSIZE*L*)
CSTACKMIN=0;(*WHATEVER IS CONVENIENT*)
CSTEP=1;(*CSTACK INCREMENT*)
CSTACKMAX=30;(*CSTACKMIN+CSIZE*CSTEP*)
NUMINSTR=75;
RAMMIN=-57(*USER-W*57,OR LOWER,READABLE*);
MAXORD=127;(*7 BIT FOR DEC-20,READABLE*)
RAMMAX=8000;(*=RAMMIN+W*4000 AT LEAST,READABLE BY USER*)
COMPBUF=7000;(*=RAMMAX-W*200,OR LOWER,READABLE BY USER*)
SSIZE=200;(*READABLE BY USER*)
RSIZE=30;(*READABLE BY USER*)
RSTACKMIN=0;(*ARBITRARY,HIDDEN*)
RSTACKMAX=30;(*RSTACKMIN+R*RSIZE*)
LSIZE=30;(*READABLE BY USER*)
CSIZE=30;(*READABLE BY USER*)
(*VOCABULARY STACK IS LOCATED IN RAM*)
VSIZE=8;(*VOCAB STACK,READABLE BY USER*)
VBASE=1;(*=USER +W,READABLE BY USER*)
STRINGSMIN=7000(*READABLE BY USER*);
SYNTAXBASE=7001(*STRINGSMIN+1*);
STRINGSMAX=12000;(*STRINGSMIN+ 3000..5000 INTENDED FOR EDIT AREA *)
MAXLINNO=300;(*MAX # OF LINES POSSIBLE IN EDIT BUFFER,
READABLE BY USER*)
LINEBUF=9800;(*STRINGSMIN+2800,READABLE BY USER*)
CHKLMT=20(*SIZE OF CHECK STACK,READABLE BY USER*);
FALS=0; TRU=-1;
(* OPCODES WHOSE VALUES ARE NOT CRITICAL; THEY MUST BE
UNIQUE AND RECOGNIZEABLE BY KERNQ, AND SEPERABLE
INTO PINT1 AND PINT2 *)
PSEMICOLON=0;
WSTORE=1;
TIMES=2;
PLUS=3;
SUBTRACT=4;
DIVMOD=5;
PIF=6;
WAT=7;
ABRT=8;
SP=9;
LOAD=10;
PELSE=11;
WRD=12;
RP=13;
DROPOP=14;
PUSER=15;
EXEC=16;
EXITOP=17;
LIT=18;
STRLIT=19;
RPOP=20;
SWP=21;
TYI=22;
TYO=23;
RPSH=24;
SEMICF=25;
RAT=26;
COMPME=27;
COMPHERE=28;
DOLLARC=29;
COLON=30;
SEMICOLON=31;
IFOP=32;
ELSEOP=33;
THENOP=34;
DOOP=35;
LOOPOP=36;
BEGINOP=37;
ENDOP=38;
REPET=39;
PERCENT=40;
PDOLLAR=41;
PCOLON=42;
CASAT=43;
PDOOP=44;
PPLOOP=45;
PLLOOP=46;
CAT=47;
CSTORE=48;
PLOOP=49;
GT=50;
SEMIDOL=51;
KRNQ=52;
(* OPCODES 53,54 NOT USED AT MOMENT *)
SAT=55;
FINDOP=56;
LISTFIL=57;
(* OPCODE 58 MOMENTARILY UNUSED *)
LAT=59;
OFCAS=60;
CCOLON=61;
SEMICC=62;
NDCAS=63;
POFCAS=64;
PCCOL=65;
PSEMICC=66;
GTLIN=67;
WORD=68;
OPENR=69;
OPENW=70;
READL=71;
WRITL=72;
CORDMP=73;
RESTOR=74;
(* END OF OPCODE DECLARATIONS *)
TYPE DALFA = PACKED ARRAY[1..20] OF CHAR;
IMAGE= RECORD
STRINGS:PACKED ARRAY[STRINGSMIN..STRINGSMAX] OF CHAR;
RAM:ARRAY[RAMMIN..RAMMAX] OF INTEGER;
END(*RECORD*);
IMFILE=FILE OF IMAGE;
VAR
IMAGENAME,NAMEIN,NAMOUT,INFIL1,LISTNAME,NULLNAME:DALFA;
IP:INTEGER;(*INSTRUCTION POINTER*)
INSTR:INTEGER;(*INSTRUCTION CURRENTLY EXECUTED BY INTERPRET*)
SAVINSTR:INTEGER(*SAVES INSTR DURING TRACING*);
SAVLEVEL:INTEGER(*SAVES LEVEL DURING TRACING*);
TEMP: INTEGER;
EDIN,EDOUT,LDFIL1,LIST,OUTPUT:TEXT;
SAVEFILE:IMFILE;
NOPEN,FEOF,UNDFLO,OVFLO,SYNT,ID,REDEF,ADDR,VAL,I,DIVBY0:INTEGER;
CONVERTED:BOOLEAN;
C:CHAR;
(* RAM[RAMMIN...]:
RAM[USER-W*57]=MAXLINNO
RAM[USER-W*56]=CHKLMT
RAM[USER-W*55]=RAMMIN
RAM[USER-W*54]=STRINGSMIN
RAM[USER-W*53]=**TO BE RECYCLED**
RAM[USER-W*52]=ABORT PATCH
RAM[USER-W*51]=USER CONVERSION PATCH
RAM[USER-W*50]=PROMPT PATCH
RAM[USER-W*49]=STRINGSMAX
RAM[USER-W*48]=VBASE
RAM[USER-W*47]=VSIZE
RAM[USER-W*46]=CSIZE
RAM[USER-W*45]=LSIZE
RAM[USER-W*44]=RSIZE
RAM[USER-W*43]=SSIZE
RAM[USER-W*42]=LINEBUF
RAM[USER-W*41]=COMPBUF
RAM[USER-W*40]=RAMMAX
RAM[USER-W*39]=MAXORD =127 FOR 7 BIT CHARACTER REP.
RAM[USER-W*38]=MAXINT
RAM[USER-W*37]=**TO BE RECYCLED**
RAM[USER-W*36]=VERSION =11 (1.1)
RAM[USER-W*35]=SESSION DONE BOOLEAN
RAM[USER-W*34]=^PISTOL<
RAM[USER-W*33]=0(FOR PISTOL)
RAM[USER-W*32]=^VSTACK(CONTEXT)
FILE STATUS: NEGATIVE VALUE MEANS EOF FOR INPUT
OR FILE OPENED FOR WRITE;
MAGNETUDE OF VALUE=LINES OF TEXT
TRANSFERED SINCE FILE WAS OPENED.
RAM[USER-W*31]=STATUS FOR EDOUT
RAM[USER-W*30]=STATUS FOR EDIN
RAM[USER-W*29]=STATUS FOR LDFIL1
RAM[USER-W*28]=#GETLINE ADDRESS
RAM[USER-W*27]=TAB SIZE, NORMALLY 8
RAM[USER-W*26]=TRACE PATCH ADDRESS
RAM[USER-W*25]=ENDCASE PATCH ADDRESS
RAM[USER-W*24]=COLUMN
RAM[USER-W*23]=TERMINAL WIDTH
RAM[USER-W*22]=# OF LINES OUTPUT TO CONSOLE
RAM[USER-W*21]=TERMINAL PAGE,MAX # OF LINES
RAM[USER-W*20]=COMPILE-END-PATCH
USED TO SHOW CONTENTS OF COMPILE BUFFER
RAM[USER-W*19]=TRACE BOOLEAN AND LEVEL
RAM[USER-W*18]=HEAD OF TOKEN IN LINE
RAM[USER-W*17]=RAISE LC-->UC BOOLEAN
RAM[USER-W*16]=LINELENGTH
RAM[USER-W*15]=NEXTCH POINTER
RAM[USER-W*14]=CONSOLE OUT BOOLEAN
RAM[USER-W*13]=ECHO BOOLEAN
RAM[USER-W*12]=LIST BOOLEAN
RAM[USER-W*11]=INPUT FILE
RAM[USER-W*10..-7]=SYS TEMPS
RAM[USER-W*6]=CURRENT (POINTER)
RAM[USER-W*5]=OLD END OF STRINGS
RAM[USER-W*4]=CURRENT END OF STRINGS
RAM[USER-W*3]=.D
RAM[USER-W*2]=.C
RAM[USER-W*1]=RADIX
RAM[VBASE..VBASE+VSIZE]=VOCABULARY STACK
RAM[VBASE+VSIZE..NUMINSTR]=NOT USED HERE *)
MEMORY:IMAGE;
STKPTR:INTEGER;
RPTR:INTEGER;
LPTR:INTEGER;
CPTR:INTEGER;
(* STRINGS[STRINGSMIN] RADIX INDICATOR
STRINGS[SYNTAXBASE] DEPTH OF NESTING &
CHECKSTACK POINTER *)
RSTACK:ARRAY[RSTACKMIN..RSTACKMAX] OF INTEGER;
STACK:ARRAY[MSTACKMIN..PSTACKMAX] OF INTEGER;
LSTACK:ARRAY[LSTACKMIN..LSTACKMAX] OF INTEGER;
CSTACK:ARRAY[CSTACKMIN..CSTACKMAX] OF INTEGER;
(* VSTACK LOCATED IN LOW RAM *)
PROCEDURE ABORT;
FORWARD;(*RECURSION NEEDED HERE ONLY FOR CARRET,BELOW:*)
PROCEDURE CARRET(*OUTPUTS A CR-LF SEQUENCE*);
BEGIN
WITH MEMORY DO BEGIN
IF RAM[USER-W*14]<>FALS
THEN BEGIN
RAM[USER-W*22]:=RAM[USER-W*22]+1;
IF RAM[USER-W*22]=RAM[USER-W*21]
THEN BEGIN
READLN(INPUT);
READ(INPUT,C);
RAM[USER-W*22]:=0;
IF (C='Q') OR (C='q') THEN ABORT;
END;
RAM[USER-W*24]:=0;
WRITELN(OUTPUT);
END;
IF RAM[USER-W*12]<>FALS THEN WRITELN(LIST);
END(*WITH MEMORY*);
END(*CARRET*);
PROCEDURE SPACES(NUM:INTEGER);
FORWARD; (* NEEDED BY TAB, BELOW: *)
PROCEDURE TAB;
BEGIN
WITH MEMORY DO BEGIN
IF RAM[USER-W*27]>0
THEN SPACES(RAM[USER-W*27]-(RAM[USER-W*24] MOD RAM[USER-W*27]));
END(*WITH MEMORY*);
END(*TAB*);
PROCEDURE CHOUT(CH:CHAR);
(* OUTPUTS A CHARACTER*)
BEGIN
WITH MEMORY DO BEGIN
IF CH=CHR(13) THEN CARRET
ELSE IF CH=CHR(9) THEN TAB
ELSE BEGIN
IF RAM[USER-W*24]=RAM[USER-W*23] THEN CARRET;
RAM[USER-W*24]:=RAM[USER-W*24]+1;
IF RAM[USER-W*14]<>FALS THEN WRITE(OUTPUT,CH);
IF RAM[USER-W*12]<>FALS THEN WRITE(LIST,CH);
END
END(*WITH MEMORY*);
END(*CHOUT*);
PROCEDURE SPACES;
BEGIN
WHILE NUM>0 DO
BEGIN
CHOUT(' ');
NUM:=NUM-1;
END(*WHILE*)
END(*SPACES*);
PROCEDURE MESSAGE(ST:INTEGER);
BEGIN
WITH MEMORY DO BEGIN
IF ORD(STRINGS[ST])>0 THEN
BEGIN
RAM[USER-W*10]:=ST+ORD(STRINGS[ST]);(*LAST*)
REPEAT
ST:=ST+1;
CHOUT(STRINGS[ST]);
UNTIL ST=RAM[USER-W*10];
END(*IF*)
END(*WITH MEMORY*);
END(*MESSAGE*);
PROCEDURE INTERPRET(I:INTEGER);
FORWARD;(*NEEDED IN ABORT,PROMPT
FOR USER SUPPLIED PATCHES*)
PROCEDURE ABORT;
(* RESETS STACKS
RETURNS I/O TO TTY:
PRODUCES SIGNON MSG *)
BEGIN
WITH MEMORY DO BEGIN
IP:=COMPBUF;(*SO RAM[IP] IS NOT OUT OF RANGE*)
RAM[USER-W*35]:=FALS;(*SESSION NOT DONE*)
RAM[USER-W*32]:=VBASE;
RAM[VBASE]:=USER-W*34;
RAM[USER-W*6]:=USER-W*34;
STKPTR := STACKMIN;
RPTR := RSTACKMIN-R;
CPTR := CSTACKMIN;
LPTR := LSTACKMIN;
STRINGS[SYNTAXBASE] := CHR(0);
RAM[USER-W*11]:=FALS;(*RETURN TO CONSOLE INPUT*)
RAM[USER-W*14]:=TRU;(*TURN ON CONSOLE OUTPUT*)
IF LISTNAME=NULLNAME THEN RAM[USER-W*12]:=FALS;
(*TURN OFF LISTING IF NO LISTFILE IS OPEN*)
MESSAGE(ID);
(* IFCR *)
IF RAM[USER-W*24]>0 THEN CARRET;
RAM[USER-W*19]:=FALS;(*TURN TRACE OFF, IF NECESSARY*)
IF RAM[USER-W*52]<>FALS
THEN INTERPRET(RAM[USER-W*52]);(*USER SUPPLIED SUPPLEMENT TO ABORT*)
GOTO 99;
END(*WITH MEMORY*);
END(*ABORT*);
PROCEDURE MERR(M:INTEGER);(*MESSAGE-ERROR*)
BEGIN
MEMORY.RAM[USER-W*14]:=TRU;(*TURN ON CONSOLE*)
(* IFCR *)
IF MEMORY.RAM[USER-W*24]>0 THEN CARRET;
MESSAGE(M);
ABORT;
END(*MERR*);
PROCEDURE SYNTERR;
BEGIN
WITH MEMORY DO BEGIN
RAM[USER-W*14]:=TRU; (*TURN ON CONSOLE*)
(* IFCR *)
IF RAM[USER-W*24]>0 THEN CARRET;
IF (RAM[USER-W*11]<>FALS) AND (RAM[USER-W*13]=FALS) THEN MESSAGE(LINEBUF);
MERR(SYNT);
END(*WITH MEMORY*);
END(*SYNTERR*);
PROCEDURE PUSH(ITEM:INTEGER); (*PARAMETER STACK*)
BEGIN
STKPTR:=STKPTR+S;
IF STKPTR>=STACKMAX THEN MERR(OVFLO);
STACK[STKPTR]:=ITEM;
END(*PUSH*);
PROCEDURE RPRAISE;(*RAISE RETURN STACK POINTER*)
BEGIN
RPTR:=RPTR+R;
IF RPTR>=RSTACKMAX THEN MERR(OVFLO)
END(*RPRAISE*);
(*RSTACK USED FOR RETURN ADDRESSES ONLY;
NOT FOR CASE OR LOOP STRUCTURES*)
PROCEDURE RPUSH(ITEM:INTEGER); (*ON RETURN STACK*)
BEGIN
RPRAISE;
RSTACK[RPTR]:=ITEM;
END(*RPUSH*);
PROCEDURE LPUSH(ITEM:INTEGER);
BEGIN
LPTR:=LPTR+L;
IF LPTR>=LSTACKMAX THEN MERR(OVFLO);
LSTACK[LPTR]:=ITEM;
END(*LPUSH*);
PROCEDURE CPUSH(ITEM:INTEGER);(*FOR CASE STACK*)
BEGIN
CPTR:=CPTR+CSTEP;
IF CPTR>=CSTACKMAX THEN MERR(OVFLO);
CSTACK[CPTR]:=ITEM;
END(*CPUSH*);
PROCEDURE PUSHCK(CHKCH:CHAR); (*PLACE ON CHARACTER CHECK STACK*)
BEGIN
WITH MEMORY DO BEGIN
STRINGS[SYNTAXBASE]:= CHR(ORD(STRINGS[SYNTAXBASE])+1);
IF ORD(STRINGS[SYNTAXBASE])<CHKLMT
THEN STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] := CHKCH
ELSE BEGIN
RAM[USER-W*14]:=TRU; (*TURN ON CONSOLE*)
MESSAGE(OVFLO);
SYNTERR;
END
END(*WITH MEMORY*);
END(*PUSHCK*);
PROCEDURE APPEND(ITEM:INTEGER); (*PUT ITEM AT END OF DICTIONARY*)
BEGIN
WITH MEMORY DO BEGIN
RAM[RAM[USER-W*3]] := ITEM;
RAM[USER-W*3] := RAM[USER-W*3]+W;
IF RAM[USER-W*3]>=COMPBUF THEN MERR(OVFLO);
END(*WITH MEMORY*);
END(*APPEND*);
PROCEDURE ALOOP;(*USED BY (LOOP) AND BY (+LOOP) *)
BEGIN
IF LSTACK[LPTR]<LSTACK[LPTR-L]
THEN (*BRANCH*) IP:=IP+MEMORY.RAM[IP]
ELSE BEGIN
LPTR:=LPTR-L*3;
IF LPTR<LSTACKMIN THEN MERR(UNDFLO);
(*SKIP*) IP:=IP+W
END
END(*ALOOP*);
PROCEDURE DROP;(*FROM PARAMETER STACK*)
BEGIN
IF STKPTR<S THEN MERR(UNDFLO)
ELSE STKPTR := STKPTR-S
END(*DROP*);
PROCEDURE PDO;(* (DO) *)
BEGIN
DROP;
DROP;
IF STACK[STKPTR+S*2]<STACK[STKPTR+S]
THEN BEGIN
LPUSH(STACK[STKPTR+S*2]);(*START VALUE*)
LPUSH(STACK[STKPTR+S]);(*END VALUE*)
LPUSH(STACK[STKPTR+S*2]);(*ITERATION VAR*)
(*SKIP*) IP:=IP+W
END
ELSE (*BRANCH*) IP:=IP+MEMORY.RAM[IP]
END(*PDO*);
PROCEDURE DROPCK;
BEGIN
WITH MEMORY DO BEGIN
IF ORD(STRINGS[SYNTAXBASE])>0
THEN STRINGS[SYNTAXBASE] := CHR(ORD(STRINGS[SYNTAXBASE])-1)
ELSE SYNTERR
END(*WITH MEMORY*);
END(*DROPCK*);
FUNCTION VFIND(PTOKEN:INTEGER; LOC:INTEGER;V:INTEGER):INTEGER;
(*PTOKEN POINTS TO THE LOCATION IN STRINGS THAT
THE START OF THE TOKEN IS; THIS TOKEN
IS LOOKED UP IN VOCABULARY INDIRECTLY POINTED
BY V AND THE ADDRESS IS RETURNED BY VFIND *)
(*RETURNS POINTER TO PF IF MATCHED OTHERWISE LOC:=0*)
(* RAM[USER-W*10]=STRING CURSOR
RAM[USER-W*9]=LENGTH
RAM[USER-W*8]=MATCH:BOOLEAN
RAM[USER-W*7]=TEMPORARY *)
BEGIN
WITH MEMORY DO BEGIN
RAM[USER-W*9]:=ORD(STRINGS[PTOKEN]);
LOC:=RAM[RAM[V]];
IF LOC<>FALS THEN
REPEAT
RAM[USER-W*8]:=TRU;
IF STRINGS[RAM[LOC-W*2]]=CHR(RAM[USER-W*9])
THEN BEGIN
RAM[USER-W*7]:=0;
REPEAT
RAM[USER-W*7]:=RAM[USER-W*7]+1;
UNTIL (STRINGS[RAM[LOC-W*2]+RAM[USER-W*7]])
<>(STRINGS[PTOKEN+RAM[USER-W*7]]);
IF RAM[USER-W*7]<(RAM[USER-W*9]+1) THEN
RAM[USER-W*8]:=FALS;
END(*THEN*)
ELSE RAM[USER-W*8]:=FALS;
IF RAM[USER-W*8]=FALS THEN LOC:=RAM[LOC-W*3]
UNTIL (RAM[USER-W*8]<>FALS) OR (LOC=FALS);
VFIND:=LOC;
END(*WITH MEMORY*);
END(*VFIND*);
FUNCTION FIND(PTOKEN:INTEGER; LOC:INTEGER):INTEGER;
VAR V:INTEGER;
BEGIN
V:=MEMORY.RAM[USER-W*32];
REPEAT
LOC:=VFIND(PTOKEN,LOC,V);
V:=V-W;
UNTIL (V<VBASE) OR (LOC<>FALS);
FIND:=LOC;
END(*FIND*);
(* HEADER: ENDA:CODE END,NORMALLY POINTS TO RET
NFA:STRINGS
COMPA:CF
EXECA:PF *)
PROCEDURE ENTER(*CREATES AN ENTRY FOR TOKEN POINTED TO
BY TOP OF PARAMETER STACK*);
BEGIN
WITH MEMORY DO BEGIN
DROP;
TEMP:=FIND(STACK[STKPTR+S],TEMP);
IF TEMP<>FALS THEN
BEGIN
MESSAGE(REDEF);
SPACES(3);
MESSAGE(STACK[STKPTR+S]);
CARRET
END(*IF*);
APPEND(0);(*FOR ENDA*)
APPEND(RAM[RAM[USER-W*6]]);
APPEND(STACK[STKPTR+S]);
APPEND(COMPHERE);(* (:) *)
RAM[RAM[USER-W*6]]:=RAM[USER-W*3];(*CURRENT:=EXECA*)
END(*WITH MEMORY*);
END(*ENTER*);
PROCEDURE FENTER(I:INTEGER);(*FINISH MOST RECENT ENTRY
FILLING IN ENDA WITH I *)
BEGIN
WITH MEMORY DO BEGIN
RAM[RAM[RAM[USER-W*6]]-W*4] := I
END(*WITH MEMORY*)
END(*FENTER*);
PROCEDURE GEOLN;
(* ADVANCES TO EOLN*)
BEGIN
WITH MEMORY DO
WHILE STRINGS[RAM[USER-W*15]]<>CHR(13) DO RAM[USER-W*15]:=RAM[USER-W*15]+1;
END(*GEOLN*);
PROCEDURE GETLINE;
(*BUFFERS INPUT LINE INTO STRINGS[LINEBUF]*)
VAR CH:CHAR;
BEGIN(*GETLINE*)
WITH MEMORY DO BEGIN
RAM[USER-W*16]:=0;(*LINELENGTH*)
RAM[USER-W*15]:=LINEBUF;
IF RAM[USER-W*11]=FALS
THEN BEGIN
READLN(INPUT);
WHILE NOT EOLN(INPUT) DO
BEGIN
READ(INPUT,CH);
IF RAM[USER-W*12]<>FALS
THEN WRITE(LIST,CH);
RAM[USER-W*16]:=RAM[USER-W*16]+1;
RAM[USER-W*15]:=RAM[USER-W*15]+1;
STRINGS[RAM[USER-W*15]]:=CH;
END(*WHILE*);
IF RAM[USER-W*12]<>FALS
THEN WRITELN(LIST);
END(*THEN*);
IF RAM[USER-W*11]<>FALS (* CANNOT BE USED TO LOAD FROM EDITBUF*)
THEN BEGIN
IF EOF(LDFIL1) THEN MERR(FEOF);
WHILE NOT EOLN(LDFIL1) DO
BEGIN
READ(LDFIL1,CH);
RAM[USER-W*16]:=RAM[USER-W*16]+1;
RAM[USER-W*15]:=RAM[USER-W*15]+1;
STRINGS[RAM[USER-W*15]]:=CH;
END(*WHILE*);
READLN(LDFIL1);
IF EOF(LDFIL1) THEN RAM[USER-W*29]:=-RAM[USER-W*29]
ELSE RAM[USER-W*29]:=RAM[USER-W*29]+1;
END(*THEN*);
STRINGS[LINEBUF]:=CHR(RAM[USER-W*16]+1);
STRINGS[RAM[USER-W*15]+1]:=CHR(13);
RAM[USER-W*15]:=LINEBUF+1;
(**ECHO:**)
IF (RAM[USER-W*13]<>FALS) AND (RAM[USER-W*11]<>FALS)
THEN MESSAGE(LINEBUF);
END(*WITH MEMORY*);
END(*GETLINE*);
PROCEDURE MOVE(AS:INTEGER; AD:INTEGER; NOWD:INTEGER);
(* AS:ADDRESS OF SOURCE BLOCK
AD:ADDRESS OF DESTINATION
NOWD:NUMBER OF WORDS*W TO BE MOVED *)
VAR ENDADDR:INTEGER;
BEGIN(*MOVE*)
ENDADDR:=AS+NOWD;
REPEAT
MEMORY.RAM[AD]:=MEMORY.RAM[AS];
AD:=AD+W;
AS:=AS+W;
UNTIL AS>ENDADDR
END(*MOVE*);
PROCEDURE SLIT(VAR START:INTEGER);
(* EMPLACES THE TOKEN POINTED TO BY RAM[USER-W*4] INTO
STRINGS AND POINTS TO ITS START*)
VAR LENGTH, I:INTEGER;
BEGIN
WITH MEMORY DO BEGIN
START:=RAM[USER-W*4];
LENGTH:=ORD(STRINGS[START])-1;
FOR I:= 1 TO LENGTH
DO STRINGS[START+I]:=STRINGS[START+I+1];
STRINGS[START]:=CHR(LENGTH);
RAM[USER-W*4]:=RAM[USER-W*4]+LENGTH+1
END(*WITH MEMORY*);
END(*SLIT*);
PROCEDURE SWAP;(*TOP TWO ITEMS ON PARAMETER STACK*)
BEGIN
STACK[STKPTR+S]:=STACK[STKPTR];
STACK[STKPTR]:=STACK[STKPTR-S];
STACK[STKPTR-S]:=STACK[STKPTR+S]
END(*SWAP*);
PROCEDURE NEXTCH;
(*ADVANCES POINTER, RAM[USER-W*15] TO NEXT CHARACTER IN
BUFFERED INPUT LINE; WILL NOT ADVANCE BEYOND
A CARRIAGE RETURN *)
BEGIN
WITH MEMORY DO BEGIN
IF STRINGS[RAM[USER-W*15]] <> CHR(13)
THEN RAM[USER-W*15]:=RAM[USER-W*15]+1;
END(*WITH MEMORY*);
END(*NEXTCH*);
PROCEDURE PROMPT;
BEGIN
WITH MEMORY DO BEGIN
IF RAM[USER-W*50]<>FALS THEN INTERPRET(RAM[USER-W*50])(*SPECIAL USER PROMPT*)
ELSE
BEGIN(*PRIMITIVE PROMPT*)
(* IFCR *)
IF RAM[USER-W*24]>0 THEN CARRET;
IF RAM[USER-W*14]<>FALS THEN WRITE(OUTPUT,STRINGS[STRINGSMIN]);
IF RAM[USER-W*12]<>FALS THEN WRITE(LIST,STRINGS[STRINGSMIN]);
MESSAGE(SYNTAXBASE);
IF RAM[USER-W*14]<>FALS THEN WRITE(OUTPUT,'> ');
IF RAM[USER-W*12]<>FALS THEN WRITE(LIST,'> ');
END(*STANDARD PROMPT*)
END(*WITH MEMORY*);
END(*PROMPT*);
PROCEDURE IGNRBLNKS;
(*ADVANCES RAM[USER-W*15] TO POINT TO NEXT NON-BLANK, ETC.
CHARACTER IN BUFFERED INPUT LINE; WILL NOT
ADVANCE BEYOND A CARRIAGE RETURN*)
BEGIN WITH MEMORY DO
WHILE ORD(STRINGS[RAM[USER-W*15]]) IN [0,9,10,32]
DO NEXTCH
END(*IGNRBLNKS*);
PROCEDURE LONGSTRING(VAR START:INTEGER);
(*EMPLACES "STRING" POINTED TO BY RAM[USER-W*18] INTO STRINGS
AND POINTS TO ITS START*)
VAR LENGTH:INTEGER;
BEGIN(*LONGSTRING*)
WITH MEMORY DO BEGIN
IF STRINGS[RAM[USER-W*18]]<>'"' THEN ABORT;
START:=RAM[USER-W*4];
LENGTH:=0;
RAM[USER-W*15]:=RAM[USER-W*18]+1; (*RESET NEXTCH POINTER*)
WHILE NOT(ORD(STRINGS[RAM[USER-W*15]]) IN [13,34])
DO BEGIN
LENGTH := LENGTH+1;
STRINGS[START+LENGTH]:=STRINGS[RAM[USER-W*15]];
NEXTCH;
END(*WHILE NOT*);
NEXTCH;
STRINGS[START]:=CHR(LENGTH);
RAM[USER-W*4]:=START+LENGTH+1;
END(*WITH MEMORY*);
END(*LONGSTRING*);
PROCEDURE INTOKEN;
(* PLACES STRING AT END OF STRINGS SO THAT
RAM[USER-W*4] POINTS TO IT *)
BEGIN
WITH MEMORY DO BEGIN
RAM[USER-W*9]:=0;
REPEAT
RAM[USER-W*9]:=RAM[USER-W*9]+1;
IF (STRINGS[RAM[USER-W*15]]>='a')
AND (STRINGS[RAM[USER-W*15]]<='z')
AND (RAM[USER-W*17]<>FALS)
THEN(*RAISE TO UPPERCASE*)
STRINGS[RAM[USER-W*9]+RAM[USER-W*4]]:=
CHR(ORD(STRINGS[RAM[USER-W*15]])-32)
ELSE(*NO NEED TO RAISE*)
STRINGS[RAM[USER-W*9]+RAM[USER-W*4]]:=
STRINGS[RAM[USER-W*15]];
NEXTCH
UNTIL ORD(STRINGS[RAM[USER-W*15]]) IN [0,9,10,13,32];
STRINGS[RAM[USER-W*4]]:=CHR(RAM[USER-W*9]);
END(*WITH MEMORY*);
END(*INTOKEN*);
FUNCTION DIGIT(D:INTEGER):INTEGER;
(*CONVERTS ORD(ASCII) INTO NUMERICAL EQUIVALENT*)
(*ERROR CONDITION FOR ARGUMENT PRODUCES NEGATIVE RESULT*)
BEGIN
IF D<=ORD('9')
THEN DIGIT:=D-ORD('0')
ELSE IF D<ORD('A')
THEN DIGIT:=-1
ELSE IF D<=ORD('Z')
THEN DIGIT:=10+D-ORD('A')
ELSE DIGIT:=-1
END(*DIGIT*);
PROCEDURE COMPILE(ADDRESS:INTEGER);
(*"PUSHES" ADDRESS ONTO COMPILE BUFFER "STACK"*)
BEGIN
WITH MEMORY DO BEGIN
RAM[RAM[USER-W*2]]:=ADDRESS;
RAM[USER-W*2]:=RAM[USER-W*2]+W;
IF RAM[USER-W*2]>=RAMMAX THEN MERR(OVFLO) ;
END(*WITH MEMORY*);
END(*COMPILE*);
PROCEDURE FWDREF;(*COMPILES 0 TO PROVIDE SPACE FOR TOUCHUP TO USE*)
BEGIN
PUSH(MEMORY.RAM[USER-W*2]);
COMPILE(0);(*TO BE OVERWRITTEN*)
END(*FWDREF*);
PROCEDURE CONVERT(PTKN:INTEGER;BASE:INTEGER;VAR OK:BOOLEAN;
VAR VALUE:INTEGER);
(*INPUT NUMBER CONVERSION ROUTINE*)
VAR TEND:INTEGER(*TOKEN END*);
(* RAM[USER-W*10]=SIGN
RAM[USER-W*9]=STRING CURSOR *)
BEGIN
WITH MEMORY DO BEGIN
VALUE:=0;
RAM[USER-W*10]:=+1;
TEND:=ORD(STRINGS[PTKN])+PTKN+1;
IF STRINGS[PTKN+1]='+'THEN RAM[USER-W*9]:=PTKN+2
ELSE IF STRINGS[PTKN+1]='-' THEN
BEGIN RAM[USER-W*10]:=-1;
RAM[USER-W*9]:=PTKN+2
END
ELSE RAM[USER-W*9]:=PTKN+1;
WHILE(DIGIT(ORD(STRINGS[RAM[USER-W*9]]))<BASE) AND
(DIGIT(ORD(STRINGS[RAM[USER-W*9]]))>-1) AND (RAM[USER-W*9]<TEND)
DO BEGIN
VALUE:=BASE*VALUE+DIGIT(ORD(STRINGS[RAM[USER-W*9]]));
RAM[USER-W*9]:=RAM[USER-W*9]+1;
END;
VALUE:=VALUE*RAM[USER-W*10];
IF RAM[USER-W*9]=TEND
THEN OK:=TRUE
ELSE OK:=FALSE;
END(*WITH MEMORY*);
END(*CONVERT*);
PROCEDURE TOUCHUP;(*FOR FORWARD REFERENCES*)
(*OVERWRITES 0 LEFT BY FWDREF WITH RELATIVE DISPLACEMENT
TO CURRENT LOCATION IN COMPILE BUFFER*)
BEGIN
MEMORY.RAM[STACK[STKPTR]]:=MEMORY.RAM[USER-W*2]-STACK[STKPTR];
DROP;
END(*TOUCHUP*);
PROCEDURE PERMSTRINGS;
(* UPDATES RAM[USER-W*5] TO POINT TO NEW TOP OF PERMANENT
STRING AREA*)
BEGIN
WITH MEMORY DO
IF RAM[USER-W*5]<RAM[USER-W*4]
THEN RAM[USER-W*5]:=RAM[USER-W*4]
END(*PERMSTRINGS*);
PROCEDURE PINT(INST:INTEGER);
FORWARD;
PROCEDURE PINT0(INST:INTEGER);
(*PRIMITIVE INTERPRETATION OF [0..40]*)
BEGIN
WITH MEMORY DO BEGIN
CASE INST OF
PSEMICOLON: (* (;) *)BEGIN
IP:=RSTACK[RPTR];
RPTR:=RPTR-R;
END(* (;) *);
WSTORE: (* W! *)BEGIN DROP; DROP;
RAM[STACK[STKPTR+S*2]]:=STACK[STKPTR+S];
END;
TIMES: (* * *)
BEGIN
STACK[STKPTR-S]:=STACK[STKPTR-S]*STACK[STKPTR];
DROP
END;
PLUS: (* + *)
BEGIN STACK[STKPTR-S]:=STACK[STKPTR-S]+STACK[STKPTR];
DROP
END;
SUBTRACT: (* - *)
BEGIN STACK[STKPTR-S]:=STACK[STKPTR-S]-STACK[STKPTR];
DROP
END;
DIVMOD: (* /MOD *)
IF STACK[STKPTR]<>0 THEN
BEGIN STACK[STKPTR+S]:=STACK[STKPTR-S] DIV STACK[STKPTR];
STACK[STKPTR]:=STACK[STKPTR-S] MOD STACK[STKPTR];
STACK[STKPTR-S]:=STACK[STKPTR+S];
END
ELSE MERR(DIVBY0);
PIF: (* 0BRANCH OR (IF) *)
BEGIN DROP;
IF STACK[STKPTR+S]=0
THEN (*BRANCH*) IP:=IP+RAM[IP]
ELSE (*SKIP*) IP:=IP+W
END;
WAT: (* W@ *)
STACK[STKPTR]:=RAM[STACK[STKPTR]];
ABRT: ABORT;
SP: (* SP *)
PUSH(STKPTR);
LOAD: (* LOAD *)
BEGIN
DROP;
RAM[USER-W*11]:=STACK[STKPTR+S];
IF RAM[USER-W*11]>MAXLINNO
THEN BEGIN
FOR I:= 1 TO 20 DO INFIL1[I]:=CHR(0);
RAM[USER-W*10]:=ORD(STRINGS[RAM[USER-W*11]]);
FOR I := 1 TO RAM[USER-W*10]
DO INFIL1[I]:=STRINGS[RAM[USER-W*11]+I];
RESET(LDFIL1,INFIL1);
RAM[USER-W*29]:=0;
END(*IF*)
END(*LOAD:*);
PELSE: (* BRANCH OR (ELSE) *)
IP:=IP+RAM[IP];
WRD: (* W *)
PUSH(W);
RP: (* RP *)
PUSH((RPTR-RSTACKMIN) DIV R);
DROPOP: DROP;
PUSER: (* USER *)
PUSH(USER);
EXEC: (* EXEC *)
BEGIN DROP;
IF (*KERNEL?*) (STACK[STKPTR+S])<NUMINSTR
THEN PINT(STACK[STKPTR+S])
ELSE BEGIN
RPUSH(IP);
IP:=STACK[STKPTR+S];
END;
END(*EXEC:*);
EXITOP: (* EXIT *)
IF LPTR<(LSTACKMIN+L*3) THEN ABORT
ELSE LSTACK[LPTR]:=LSTACK[LPTR-L];
LIT, (* LITERAL *)
STRLIT: (* STRING-LITERAL *)
(*USED TO PUSH FOLLOWING WORD ON PARAMETER STACK *)
BEGIN
PUSH(RAM[IP]);
(*SKIP*) IP:=IP+W
END(*LIT:,STRLIT:*);
RPOP: (* R> *) (*POP THE TOP OF RSTACK ONTO STACK*)
BEGIN
PUSH(RSTACK[RPTR]);
RPTR:=RPTR-R
END(*RPOP:*);
SWP: SWAP;
TYI: (* TYI *)
BEGIN
IF EOLN(INPUT) THEN READLN(INPUT);
READ(INPUT,C);
PUSH(ORD(C))
END;
TYO: (* TYO *)
BEGIN
DROP;
CHOUT(CHR(STACK[STKPTR+S]));
END(* TYO *);
RPSH: (* <R *) (*OPPOSITE TO R> , ABOVE , RPOP: *)
BEGIN
RPUSH(STACK[STKPTR]);
DROP;
END(*RPSH:*);
SEMICF: (* ;F *)
BEGIN
(* IFCR *)
IF RAM[USER-W*24]>0 THEN CARRET;
IF(RAM[USER-W*11]<MAXLINNO)AND(RAM[USER-W*11]>0)
THEN BEGIN
RAM[USER-W*11]:=RAM[USER-W*11]-1;
WRITELN(OUTPUT);
WRITELN(OUTPUT,' THROUGH LINE ',
RAM[USER-W*11]:3,'(DECIMAL) LOADED');
IF RAM[USER-W*12]<>FALS THEN
BEGIN
WRITELN(LIST);
WRITELN(LIST,' THROUGH LINE ',
RAM[USER-W*11]:3,'(DECIMAL) LOADED');
END(*IF RAM[USER-W*12]<>FALS*)
END(*<MAXLINNO*);
IF (RAM[USER-W*11]>=MAXLINNO)
THEN BEGIN
WRITELN(OUTPUT,INFIL1,' LOADED');
IF RAM[USER-W*12]<>FALS THEN WRITELN(LIST,INFIL1,' LOADED');
END(* >=MAXLINNO *);
RAM[USER-W*11]:=0;
END(*SEMICF:*);
RAT: (* R@ *)
BEGIN
DROP;
IF((RPTR-R*STACK[STKPTR+S])<RSTACKMIN) THEN MERR(UNDFLO);
PUSH(RSTACK[RPTR-R*STACK[STKPTR+S]]);
END(*RAT:*);
COMPME: (*COMPILEME: COMPILES FOLLOWING CODE UNTIL ENDA
VALUE IS REACHED; USED FOR PRIMITIVE-NOTIMMED.
AND FOR MACR0($:) *)
(* IF (ENDA)=(EXECA) THEN NOTHING IS COMPILED *)
BEGIN
I:=IP;
WHILE (I<RAM[IP-W*4])
DO BEGIN
COMPILE(RAM[I]);
I:=I+W;
END;
IP:=RSTACK[RPTR];
RPTR:=RPTR-R;
END(*COMPME:*);
COMPHERE: (*NOTIMMED -- USED BY COMPILER DURING COMPILETIME ONLY*)
BEGIN COMPILE(IP);
IP:=RSTACK[RPTR];
RPTR:=RPTR-R;
END(*COMPHERE:*);
DOLLARC: (* $: *)
BEGIN
PUSHCK('$');
COMPILE(PDOLLAR);(* ($:) *)
FWDREF
END;
COLON: (* : *)
BEGIN
PUSHCK(':');
COMPILE(PCOLON); (* (:) *)
FWDREF;
END;
SEMICOLON: (* ; *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]=':'
THEN BEGIN
DROPCK;
COMPILE(PSEMICOLON);(* (;) *)
TOUCHUP;
END
ELSE SYNTERR;
IFOP: (* IF *)
BEGIN
PUSHCK('F');
COMPILE(PIF);(* (IF) *)
FWDREF;
END;
ELSEOP: (* ELSE *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'F'
THEN BEGIN
STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]:='E';
COMPILE(PELSE);(* (ELSE) *)
FWDREF;
SWAP;
TOUCHUP;
END
ELSE SYNTERR;
THENOP: (* THEN *)
IF (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'F')
OR (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'E')
THEN BEGIN
DROPCK;
TOUCHUP;
END
ELSE SYNTERR;
DOOP: (* DO *)
BEGIN
PUSHCK('D');
COMPILE(PDOOP);(* (DO) *)
FWDREF;
END;
LOOPOP: (* LOOP *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='D'
THEN BEGIN
DROPCK;
COMPILE(PLOOP);(* (LOOP) *)
COMPILE(STACK[STKPTR]-RAM[USER-W*2]+W);
TOUCHUP;
END
ELSE SYNTERR;
BEGINOP: (* BEGIN *)
BEGIN
PUSHCK('B');
PUSH(RAM[USER-W*2])
END;
ENDOP: (* END *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'B'
THEN BEGIN
DROPCK;
COMPILE(PIF);(* (IF) *)
COMPILE(STACK[STKPTR]-RAM[USER-W*2]);
DROP;
END
ELSE SYNTERR;
REPET: (* REPEAT *)
BEGIN
DROPCK;
DROPCK;
IF (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE+1]='B')
AND(STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE+2]='F')
THEN BEGIN
COMPILE(PELSE);(* (ELSE) *)
COMPILE(STACK[STKPTR-S]-RAM[USER-W*2]);
TOUCHUP;
DROP;
END
ELSE SYNTERR
END(*REPET:*);
PERCENT: (* % *) GEOLN;
END(*CASE*)
END(*WITH MEMORY*);
END(*PINT0*);
PROCEDURE PINT1(INST:INTEGER);
(*PRIMITIVE INTERPRETATION OF [41..NUMINSTR-1]*)
BEGIN
WITH MEMORY DO BEGIN
CASE INST OF
PDOLLAR: (* ($:) *)
BEGIN(* SIMILAR TO PCOLON:,BELOW *)
ENTER;(*CREATE HEADER*)
MOVE(IP+W,RAM[USER-W*3],RAM[IP]-W);(*COPY CODE*)
RAM[USER-W*3]:=RAM[USER-W*3]+RAM[IP]-W;(*UPDATE .D *)
FENTER(RAM[USER-W*3]-W);(*FINISH HEADER*)
RAM[RAM[RAM[USER-W*6]]-W]:=COMPME;(*COMPILEME*)
PERMSTRINGS;
(*BRANCH*) IP:=IP+RAM[IP];
END(*PDOLLAR:*);
PCOLON: (* (:) *)
BEGIN
ENTER;(*CREATE HEADER*)
MOVE(IP+W,RAM[USER-W*3],RAM[IP]-W)(*COPY CODE*);
RAM[USER-W*3]:=RAM[USER-W*3]+RAM[IP]-W;(*UPDATE .D *)
FENTER(RAM[USER-W*3]-W);(*FINISH HEADER*)
PERMSTRINGS;
(*BRANCH*) IP:=IP+RAM[IP];
END(*PCOLON:*);
CASAT: (* CASE@ *)
(* similar to L@ , S@ , and R@ *)
BEGIN
DROP;
IF CPTR<STACK[STKPTR+S] THEN ABORT;
PUSH(CSTACK[CPTR-CSTEP*STACK[STKPTR+S]]);
END(*CASAT:*);
PDOOP: (* (DO) *) PDO;
PPLOOP: (* (+LOOP) *)
BEGIN
DROP;
LSTACK[LPTR]:=LSTACK[LPTR]+STACK[STKPTR+S];
ALOOP;
END(*PPLOOP:*);
PLLOOP: (* +LOOP *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='D'
THEN BEGIN
DROPCK;
COMPILE(PPLOOP);(* (+LOOP) *)
COMPILE(STACK[STKPTR]-RAM[USER-W*2]+W);
TOUCHUP;
END
ELSE SYNTERR;
CAT: (* C@ *)
STACK[STKPTR]:=ORD(STRINGS[STACK[STKPTR]]);
CSTORE: (* C! *)
BEGIN
DROP;
DROP;
STRINGS[STACK[STKPTR+S*2]]:=CHR(STACK[STKPTR+S]);
END(*CSTORE:*);
PLOOP: (* (LOOP) *)
BEGIN
LSTACK[LPTR]:=LSTACK[LPTR]+1;
ALOOP;
END;
GT: (* GT *)
BEGIN
DROP;
DROP;
IF STACK[STKPTR+S]>STACK[STKPTR+S*2]
THEN PUSH(TRU)
ELSE PUSH(FALS);
END(*GT:*);
SEMIDOL: (* ;$ *) (*VERY SIMILAR TO SEMICOLON:*)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='$'
THEN BEGIN
DROPCK;
COMPILE(PSEMICOLON);
TOUCHUP;
END
ELSE SYNTERR;
KRNQ: (* KERNEL? *)
BEGIN
DROP;
IF (*KERNEL?*) (STACK[STKPTR+S])<NUMINSTR
THEN PUSH(TRU)
ELSE PUSH(FALS)
END(*KRNQ:*);
53: (*CAN BE RECYCLED*)
WRITELN(OUTPUT,'OPCODE 53 USED ILLEGALLY');
54: (*CAN BE RECYCLED*)
WRITELN(OUTPUT,'OPCODE 54 USED ILLEGALLY');
SAT: (* S@ *)(*GETS ITEMS OUT OF THE STACK*)
(* 'DUP : 0 S@ ; *)
IF STACK[STKPTR]<(STKPTR-STACKMIN-S)
THEN STACK[STKPTR]:=STACK[STKPTR-S*STACK[STKPTR]-S]
ELSE MERR(UNDFLO);
FINDOP: (* FIND *)
BEGIN
DROP;
PUSH(FIND(STACK[STKPTR+S],STACK[STKPTR+S*2]));
END(*FINDOP:*);
LISTFIL: (* LISTFILE *)
BEGIN
WITH MEMORY DO BEGIN
DROP;
IF LISTNAME<>NULLNAME THEN
WRITELN(OUTPUT,' CHANGING LISTFILE NAME FROM:',
LISTNAME);
LISTNAME:=NULLNAME;
FOR I:=1 TO ORD(STRINGS[STACK[STKPTR+1]])
DO LISTNAME[I]:=STRINGS[STACK[STKPTR+1]+I];
REWRITE(LIST,LISTNAME);
END(*WITH MEMORY*)
END(*LISTFIL:*);
(* 58: MAY BE RECYCLED *)
LAT: (* L@ *)(*SIMILAR TO S@, BUT FOR LOOP STACK*)
(* 'I : 0 L@ ; *)
BEGIN
DROP;
IF LPTR<STACK[STKPTR+S] THEN ABORT;
PUSH(LSTACK[LPTR-L*STACK[STKPTR+S]]);
END(*LAT:*);
OFCAS: (* OFCASE *)
BEGIN
PUSHCK('C');
COMPILE(POFCAS);(* (OFCASE) *)
FWDREF;
END(*OFCAS:*);
CCOLON: (* C: *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='C'
THEN BEGIN
PUSHCK('c');
COMPILE(PCCOL);(* (C:) *)
FWDREF;
END
ELSE SYNTERR;
SEMICC: (* ;C *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='c'
THEN BEGIN
DROPCK;
COMPILE(PSEMICC);(* (;C) *)
TOUCHUP
END
ELSE SYNTERR;
NDCAS: (* ENDCASE *)
IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='C'
THEN BEGIN
DROPCK;
COMPILE(RAM[USER-W*25]);
TOUCHUP;
END
ELSE SYNTERR;
POFCAS: (* (OFCASE) *)
BEGIN
DROP;
STKPTR:=STKPTR+S;
CPUSH(IP+RAM[IP]);
CPUSH(STACK[STKPTR]);
(*SKIP*) IP:=IP+W;
END(*POFCAS:*);
PCCOL: (* (C:) *)
BEGIN
DROP;
IF STACK[STKPTR+S]=FALS
THEN BEGIN
PUSH(CSTACK[CPTR]);
(*BRANCH*) IP:=IP+RAM[IP];
END
ELSE (*SKIP*) IP:=IP+W;
END(*PCCOL:*);
PSEMICC: (* (;C) *)
BEGIN
CPTR:=CPTR-CSTEP*2;
IF CPTR<CSTACKMIN THEN ABORT;
IP:=CSTACK[CPTR+CSTEP];
END(*PSEMICC66:*);
GTLIN: GETLINE;
WORD: (* WORD *)
INTOKEN;
OPENR: (* OPENR *)
BEGIN
DROP;
FOR I:=1 TO 20 DO NAMEIN[I]:=CHR(0);
FOR I:=1 TO ORD(STRINGS[STACK[STKPTR+1]])
DO NAMEIN[I]:=STRINGS[STACK[STKPTR+1]+I];
RESET(EDIN,NAMEIN);
RAM[USER-W*30]:=0;
END(*OPENR*);
OPENW: (* OPENW *)
BEGIN
DROP;
FOR I:=1 TO 20 DO NAMOUT[I]:=CHR(0);
FOR I:=1 TO ORD(STRINGS[STACK[STKPTR+1]])
DO NAMOUT[I]:=STRINGS[STACK[STKPTR+1]+I];
REWRITE(EDOUT,NAMOUT);
RAM[USER-W*31]:=0;
END(*OPENW:*);
READL: (* READLINE *)
BEGIN
RAM[USER-W*16]:=0;
RAM[USER-W*15]:=LINEBUF;
IF RAM[USER-W*30]<0 THEN MERR(FEOF);
WHILE NOT EOLN(EDIN)
DO BEGIN
READ(EDIN,C);
RAM[USER-W*16]:=RAM[USER-W*16]+1;
RAM[USER-W*15]:=RAM[USER-W*15]+1;
STRINGS[RAM[USER-W*15]]:=C;
END(*WHILE*);
READLN(EDIN);
IF EOF(EDIN) THEN RAM[USER-W*30]:=-RAM[USER-W*30]-1
ELSE RAM[USER-W*30]:=RAM[USER-W*30]+1;
STRINGS[LINEBUF]:=CHR(RAM[USER-W*16]+1);
STRINGS[RAM[USER-W*15]+1]:=CHR(13);
RAM[USER-W*15]:=LINEBUF+1;
IF RAM[USER-W*13]<>FALS THEN MESSAGE(LINEBUF);
END(*READL:*);
WRITL: (* WRITELINE *)
BEGIN
DROP;
IF RAM[USER-W*31]>0 THEN MERR(NOPEN);
RAM[USER-W*9]:=STACK[STKPTR+S];
RAM[USER-W*10]:=RAM[USER-W*9]+ORD(STRINGS[RAM[USER-W*9]])-1;
WHILE RAM[USER-W*9] < RAM[USER-W*10]
DO BEGIN
RAM[USER-W*9]:=RAM[USER-W*9]+1;
WRITE(EDOUT,STRINGS[RAM[USER-W*9]]);
END(*WHILE*);
WRITELN(EDOUT);
RAM[USER-W*31]:=RAM[USER-W*31]-1;(*INCREASE NEGATIVE*)
END(*WRITL*);
CORDMP: (* COREDUMP *)
BEGIN
WITH MEMORY DO BEGIN
DROP;
FOR I:=1 TO 20 DO IMAGENAME[I]:=CHR(0);
FOR I:=1 TO ORD(STRINGS[STACK[STKPTR+S]])
DO IMAGENAME[I]:=STRINGS[STACK[STKPTR+S]+I];
REWRITE(SAVEFILE,IMAGENAME);
WRITE(SAVEFILE,MEMORY);
END(*WITH MEMORY*);
END(*CORDMP*);
RESTOR: (* RESTORE *)
BEGIN
WITH MEMORY DO BEGIN
DROP;
FOR I:=1 TO 20 DO IMAGENAME[I]:=CHR(0);
FOR I:=1 TO ORD(STRINGS[STACK[STKPTR+S]])
DO IMAGENAME[I]:=STRINGS[STACK[STKPTR+S]+I];
RESET(SAVEFILE,IMAGENAME);
READ(SAVEFILE,MEMORY);
ABORT;
END(*WITH MEMORY*);
END(*RESTOR:*);
END(*CASE*);
END(*WITH MEMORY*);
END(*PINT1*);
PROCEDURE PINT;
BEGIN
IF INST>40
THEN PINT1(INST)
ELSE PINT0(INST)
END(*PINT*);
PROCEDURE INTERPRET;(*ORIGINAL ENTRY PLACED BEFORE ABORT*)
BEGIN
WITH MEMORY DO BEGIN
INSTR:=I;
REPEAT
IP:=IP+W;
IF (*KERNEL?*) INSTR<NUMINSTR
THEN PINT(INSTR)
ELSE BEGIN
RPUSH(IP);
IP:=INSTR;
END;
INSTR:=RAM[IP];
(*TRACE PATCH*)
IF RPTR=(RAM[USER-W*19]-R*2)
THEN BEGIN
SAVINSTR:=INSTR;
SAVLEVEL:=RPTR;
INSTR:=RAM[USER-W*26];
IP:=IP-W;
REPEAT
IP:=IP+W;
IF (*KERNEL?*)
INSTR<NUMINSTR
THEN PINT(INSTR)
ELSE BEGIN
RPUSH(IP);
IP:=INSTR;
END;
INSTR:=RAM[IP];
UNTIL RPTR<(SAVLEVEL+R);
INSTR:=SAVINSTR;
END(*TRACE PATCH*);
UNTIL RPTR<RSTACKMIN;
IP:=IP-W;(*RESTORE THE ORIGINAL IP TO ORIGINAL*)
END(*WITH MEMORY*);
END(*PROCEDURE INTERPRET*);
PROCEDURE COMPLINE;
(* COMPILE AN INPUT LINE INTO THE COMPILE BUFFER*)
BEGIN
WITH MEMORY DO BEGIN
IF (RAM[USER-W*11]=FALS) OR (RAM[USER-W*13]<>FALS)
THEN PROMPT;
IF (RAM[USER-W*11]>0) AND (RAM[USER-W*11]<MAXLINNO)
THEN BEGIN
PUSH(RAM[USER-W*11]);
INTERPRET(RAM[USER-W*28]);
RAM[USER-W*11]:=RAM[USER-W*11]+1;
END(*THEN*)
ELSE
GETLINE;
IGNRBLNKS;
WHILE STRINGS[RAM[USER-W*15]] <> CHR(13) DO
BEGIN
RAM[USER-W*18] := RAM[USER-W*15]; (* NOTE TOKEN START*)
INTOKEN;
ADDR:=FIND(RAM[USER-W*4],ADDR);
IF ADDR<>FALS
THEN(*FOUND*) INTERPRET(ADDR-W) (* THE CPA *)
ELSE
BEGIN(*NOT DEFINED DURING EXECUTION*)
CONVERT(RAM[USER-W*4],RAM[USER-W*1],CONVERTED,VAL);
IF CONVERTED THEN BEGIN
COMPILE(LIT);
COMPILE(VAL)
END
ELSE
IF STRINGS[RAM[USER-W*4]+1]='''' THEN
BEGIN
SLIT(VAL);
COMPILE(STRLIT);
COMPILE(VAL);
END(*IF SINGLE-QUOTED STRING*)
ELSE IF STRINGS[RAM[USER-W*4]+1]='"' THEN
BEGIN LONGSTRING(VAL);
COMPILE(STRLIT);
COMPILE(VAL);
END(*DOUBLE QUOTED STRING*)
ELSE IF RAM[USER-W*51]<>FALS THEN INTERPRET(RAM[USER-W*51])
(*USER SUPPLIED CONVERSION*)
ELSE BEGIN (*TOKEN NOT DECHIPHERABLE*)
RAM[USER-W*14]:=TRU(*TURN ON CONSOLE*);
(*SHOW BAD LINE IF NOT ON CONSOLE*)
IF (RAM[USER-W*11]<>FALS) AND (RAM[USER-W*13]=FALS)
THEN BEGIN
(* IFCR *)
IF RAM[USER-W*24]>0
THEN CARRET;
MESSAGE(LINEBUF);
END(*IF*);
MESSAGE(RAM[USER-W*4]);
WRITELN(OUTPUT,' ?');
IF RAM[USER-W*12]<>FALS THEN WRITELN(LIST,' ?');
ABORT;
END
END(*NOT DEFINED DURING EXECUTION*);
IGNRBLNKS;
END(*WHILE*);
END(*WITH MEMORY*);
END(*PROCEDURE COMPLINE*);
PROCEDURE ADDSTRING(LENGTH:INTEGER; STRING:DALFA;VAR START:INTEGER);
(*CONVENIENCE DURING INITIALIZATION OF PISTOL*)
VAR I:INTEGER;
BEGIN(*ADDSTRING*)
WITH MEMORY DO BEGIN
START:=RAM[USER-W*4];
RAM[USER-W*4]:=RAM[USER-W*4]+1;
FOR I:= 1 TO LENGTH DO
BEGIN
STRINGS[RAM[USER-W*4]]:=STRING[I];
RAM[USER-W*4]:=RAM[USER-W*4]+1;
END(*FOR*);
STRINGS[START]:=CHR(I-1);
(* STRING HAS NOW BEEN PLACED IN STRINGS,RAM[USER-W*4]
HAS BEEN UPDATED*)
PERMSTRINGS;
END(*WITH MEMORY*);
END(*ADDSTRING*);
PROCEDURE PENTER(LENGTH:INTEGER;NAME:DALFA;OPCODE:INTEGER);
(* THIS PROCEDURE IS USED ONLY TO SIMPLIFY BRINGING UP
PISTOL; THE PRIMITIVE,"BUILT-IN" FUNCTIONS ARE
ENTERED INTO THE DICTIONARY BY THIS PROCEDURE.
IF OPCODE IS POSITIVE, IT IS 'NOTIMMEDIATE',
HENCE THE COMPILE-TIME OPCODE SHOULD BE 27, ELSE
IF OPCODE IS NEGATIVE, IT IS IMMEDIATE*)
VAR START:INTEGER;
BEGIN(*PENTER*)
WITH MEMORY DO BEGIN
ADDSTRING(LENGTH,NAME,START);
APPEND(0);(*SPACE FOR ENDA*)
APPEND(RAM[RAM[USER-W*6]]); (*LINK FIELD*)
APPEND(START); (*NAME FIELD*)
(*COMPILE-TIME FIELD: *)
IF OPCODE<0
THEN BEGIN
APPEND(-OPCODE) (*IMMEDIATE WORD*);
APPEND(PSEMICOLON) (*FOR SYMMETRY*)
END
ELSE BEGIN
APPEND(COMPME); (*PRIMITIVE NOTIMMEDIATE*)
APPEND(OPCODE);
END(*ELSE*);
RAM[RAM[USER-W*6]]:=RAM[USER-W*3]-W; (*UPDATE CURRENT*)
FENTER(RAM[USER-W*3]);(* ENDA:=.D *)
END(*WITH MEMORY*);
END(*PENTER*);
(******************************************)
BEGIN(*PISTOL MAIN*)
WITH MEMORY DO BEGIN
FOR TEMP:=RAMMIN TO RAMMAX DO RAM[TEMP]:=10000;
REWRITE(OUTPUT,'TTY: ');
FOR I:=1 TO 20 DO NULLNAME[I]:=CHR(0);
LISTNAME:=NULLNAME;
RAM[USER-W*57]:=MAXLINNO;
RAM[USER-W*56]:=CHKLMT;(*SIZE OF SYNTAX CHECKSTACK*)
RAM[USER-W*55]:=RAMMIN;
RAM[USER-W*54]:=STRINGSMIN;
RAM[USER-W*52]:=FALS;(*ABORT PATCH*)
RAM[USER-W*51]:=FALS;(*CONVERSION PATCH*)
RAM[USER-W*50]:=FALS;(*STANDARD PROMPT*)
RAM[USER-W*49]:=STRINGSMAX;
RAM[USER-W*48]:=VBASE;
RAM[USER-W*47]:=VSIZE;
RAM[USER-W*46]:=CSIZE;
RAM[USER-W*45]:=LSIZE;
RAM[USER-W*44]:=RSIZE;
RAM[USER-W*43]:=SSIZE;
RAM[USER-W*42]:=LINEBUF;
RAM[USER-W*41]:=COMPBUF;
RAM[USER-W*40]:=RAMMAX;
RAM[USER-W*39]:=MAXORD;
RAM[USER-W*38]:=MAXINT;
RAM[USER-W*36]:=VERSION;
RAM[USER-W*34]:=0;
RAM[USER-W*33]:=FALS;(* PISTOL< LINK IS NIL;
IT'S AT THE END OF BRANCH LIST*)
(*INITIALIZE FILE STATUS*)
RAM[USER-W*31]:=+1;(*EDOUT*)
RAM[USER-W*30]:=-1;(*EDIN*)
RAM[USER-W*29]:=-1;(*LDFIL1*)
RAM[USER-W*27]:=8; (*INITIALIZE TABSIZE*)
RAM[USER-W*25]:=67; (*INITIALIZE ENDCASE TO ABORT*)
RAM[USER-W*23]:=64 (* INITIALIZE TERMINAL WIDTH*);
RAM[USER-W*21]:=20 (* INITIALIZE TERMINAL PAGE LENGTH*);
RAM[USER-W*20]:=FALS;(*COMPILE-END-PATCH*)
RAM[USER-W*19]:=FALS;(*INITALIZE TRACE OFF*)
RAM[USER-W*17]:=TRU (*RAISE ON*);
RAM[USER-W*13]:=FALS (*ECHO OFF*);
RAM[USER-W*12]:=FALS;(*LIST OFF*)
RAM[USER-W*6]:=USER-W*34;
IF USER>NUMINSTR THEN RAM[USER-W*3]:=USER+W*VSIZE+W
ELSE RAM[USER-W*3]:=NUMINSTR+1;(* SET BASE OF DICTIONARY*)
RAM[USER-W*5]:=SYNTAXBASE+CHKLMT+1;
RAM[USER-W*4]:=RAM[USER-W*5];
ADDSTRING(20,'*** EOF ENCOUNTERED*',FEOF);
ADDSTRING(20,'*** FILE NOT OPENED*',NOPEN);
ADDSTRING(18,'*** PISTOL 1.3 *** ',ID);
ADDSTRING(20,'*** SYNTAX ERROR ***',SYNT);
ADDSTRING(19,'** STACK OVERFLOW **',OVFLO);
ADDSTRING(19,'* STACK UNDERFLOW * ',UNDFLO);
ADDSTRING(16,'---REDEFINING--- ',REDEF);
ADDSTRING(16,'DIVISION BY ZERO ',DIVBY0);
PENTER(2,'W! ',WSTORE);
PENTER(1,'* ',TIMES);
PENTER(1,'+ ',PLUS);
PENTER(1,'- ',SUBTRACT);
PENTER(4,'/MOD ',DIVMOD);
PENTER(2,'W@ ',WAT);
PENTER(5,'ABORT ',ABRT);
PENTER(2,'SP ',SP);
PENTER(4,'LOAD ',LOAD);
PENTER(1,'W ',WRD);
PENTER(2,'RP ',RP);
PENTER(4,'DROP ',DROPOP);
PENTER(4,'USER ',PUSER);
PENTER(4,'EXEC ',EXEC);
PENTER(4,'EXIT ',EXITOP);
PENTER(2,'R> ',RPOP);
PENTER(4,'SWAP ',SWP);
PENTER(3,'TYI ',TYI);
PENTER(3,'TYO ',TYO);
PENTER(2,'<R ',RPSH);
PENTER(2,';F ',SEMICF);
PENTER(2,'R@ ',RAT);
PENTER(2,'$: ',-DOLLARC);
PENTER(1,': ',-COLON);
PENTER(1,'; ',-SEMICOLON);
PENTER(2,'IF ',-IFOP);
PENTER(4,'ELSE ',-ELSEOP);
PENTER(4,'THEN ',-THENOP);
PENTER(2,'DO ',-DOOP);
PENTER(4,'LOOP ',-LOOPOP);
PENTER(5,'BEGIN ',-BEGINOP);
PENTER(3,'END ',-ENDOP);
PENTER(6,'REPEAT ',-REPET);
PENTER(1,'% ',-PERCENT);
PENTER(5,'CASE@ ',CASAT);
PENTER(5,'+LOOP ',-PLLOOP);
PENTER(2,'C@ ',CAT);
PENTER(2,'C! ',CSTORE);
PENTER(2,'GT ',GT);
PENTER(2,';$ ',-SEMIDOL);
PENTER(7,'KERNEL? ',KRNQ);
PENTER(2,'S@ ',SAT);
PENTER(4,'FIND ',FINDOP);
PENTER(8,'LISTFILE ',LISTFIL);
PENTER(2,'L@ ',LAT);
PENTER(6,'OFCASE ',-OFCAS);
PENTER(2,'C: ',-CCOLON);
PENTER(2,';C ',-SEMICC);
PENTER(7,'ENDCASE ',-NDCAS);
PENTER(4,'(;C) ',PSEMICC);
PENTER(7,'GETLINE ',GTLIN);
PENTER(4,'WORD ',WORD);
PENTER(5,'OPENR ',OPENR);
PENTER(5,'OPENW ',OPENW);
PENTER(8,'READLINE ',READL);
PENTER(9,'WRITELINE ',WRITL);
PENTER(8,'COREDUMP ',CORDMP);
PENTER(7,'RESTORE ',RESTOR);
RAM[USER-W*1]:=10; (*DECIMAL MODE*)
STRINGS[STRINGSMIN] := 'X';
ABORT;
REPEAT
RAM[USER-W*2]:=COMPBUF;
REPEAT
COMPLINE;
UNTIL STRINGS[SYNTAXBASE]=CHR(0);
COMPILE(PSEMICOLON);
IF RAM[USER-W*20]<>FALS THEN INTERPRET(RAM[USER-W*20]);
IF (RAM[USER-W*14]<>FALS) AND ((RAM[USER-W*11]=FALS) OR (RAM[USER-W*13]<>FALS))
THEN BEGIN
RAM[USER-W*24]:=FALS (*RESET COLUMN POSTION VARIABLE*);
RAM[USER-W*22]:=FALS (*RESET TERMINAL LINE COUNT*);
END;
INTERPRET(COMPBUF);
99:
RAM[USER-W*4]:=RAM[USER-W*5];
UNTIL RAM[USER-W*35]<>FALS(*SESSION DONE*);
WRITELN(OUTPUT,'PISTOL NORMAL EXIT');
IF RAM[USER-W*12]<>FALS THEN WRITELN(LIST,'PISTOL NORMAL EXIT');
(*FLUSH AND CLOSE FILES IF OPERATING SYSTEM DOESN'T DO IT*)
END(*WITH MEMORY*);
END.
',WORD);
PENTER(5,'OPENR ',OPENR);
PENTER(5,'OPENW ',OPENW);
PE